home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / pascal / tppulldn.zip / PULLDOWN.PAS < prev   
Pascal/Delphi Source File  |  1984-11-12  |  11KB  |  584 lines
  1. { R+}
  2. Program PullDownMenus;
  3. {
  4.  
  5. Pull Down Menus in Turbo Pascal
  6.  
  7.       by
  8.  
  9.   Kurt M. Gutzmann
  10.  
  11.  
  12.  
  13. This is a set of routines for constructing a Xerox style
  14. cum Macintosh user interface for Turbo Pascal programs.
  15.  
  16. Menus are loaded from a menu data file at start up.
  17.  
  18. The procedure RunMenus is a skeleton with a CASE statement
  19. filled by the programmer to drive his particular menu
  20. tree.
  21.  
  22. A sample menu data file and a fleshing out of the RunMenus
  23. procedure is done here as an example of how to use PullDowns.
  24.  
  25. }
  26.  
  27.  
  28.  
  29. const
  30.  
  31.        MaxItems=10; {Max Items on a Menu Bar}
  32.        MaxMenus=10; {Max Menus}
  33.        Width=11;    {Width of Pull Down Fields}
  34.  
  35. Type
  36.  
  37.    VideoMode =(Norm,Rev,Hi,Und,RevHi,Blink,BlinkHi,RevBlink,RevBlinkHi);
  38.    MaxString = String[255];
  39.    stringW = string[Width];
  40.  
  41.  
  42.    ProtoMenu = record
  43.            NumEntry :array[0..MaxItems] of integer;
  44.            Menu:array[0..MaxItems] of array[0..MaxItems] of stringW;
  45.            MenuName:stringW;
  46.            NoItems:integer;
  47.            end;
  48.  
  49.    MenuPtr = ^ProtoMenu;
  50.  
  51.    MenuAry =  array[1..MaxMenus] of MenuPtr;
  52.  
  53. var
  54.  
  55. NumMenus:integer;
  56. Menus:MenuAry;
  57. exit:boolean;
  58. VideoSeg:integer;{points to $B000 or $B800  for color or mono}
  59. botbox:maxstring;
  60.  
  61.  
  62. function ColorMonitor:boolean;
  63. {returns TRUE if a Color monitor is installed}
  64. type regpack = record
  65.        ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
  66. var regs:regpack;
  67.    al:integer;
  68. begin
  69. regs.ax:=15 shl 8;
  70. intr($10,regs);
  71. al:=Lo(regs.ax);
  72. if al=$7 then ColorMonitor:=false else ColorMonitor:=true;
  73. end;
  74.  
  75.  
  76. Procedure SetVideoSeg;
  77. begin
  78. if colormonitor then VideoSeg:=$B800 else VideoSeg:=$B000
  79. end;
  80.  
  81.  
  82. Procedure SetCursor(HiScan,LowScan:byte);
  83. type regpack = record
  84.        ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
  85. var regs:regpack;
  86. begin
  87. regs.ax:=1 shl 8;
  88. regs.cx:=HiScan shl 8 + LowScan;
  89. intr($10,regs);
  90. end;
  91.  
  92.  
  93. Procedure CursorNormal;
  94. begin
  95. if ColorMonitor then SetCursor(6,7) else  SetCursor(10,11);
  96. end;
  97.  
  98.  
  99. Procedure CursorBlock;
  100. begin
  101. if ColorMonitor then SetCursor(1,7) else  SetCursor(1,14);
  102. end;
  103.  
  104.  
  105. Procedure CursorOff;
  106. begin
  107. SetCursor(31,0);
  108. end;
  109.  
  110.  
  111.  
  112.  
  113. procedure GetKb(var chcode,extcode:integer);
  114.  
  115. (*Obtains the character and extended codes of a struck key. The codes are
  116.  removed from the buffer. This procedure will wait for a keystrike if the
  117.  buffer is empty.*)
  118.  
  119. type
  120.   RegPack = record
  121.           ax,bx,cx,dx,di,si,ds,es,flags : integer;
  122.         end;
  123. var
  124.   regs:RegPack;
  125.  
  126. begin
  127.   regs.ax := $0000;
  128.   intr($16,regs);
  129.   extcode := regs.ax shr 8;   ; (*extended code is AH*)
  130.   chcode := regs.ax and $00FF;    (*character code is AL*)
  131. end;
  132.  
  133.  
  134. function inchar(var ch:char;var ex:integer):boolean;{true if ASCII char}
  135. {Returns char and extended code from keyboard}
  136. var chcode,excode:integer;
  137. begin
  138. getkb(chcode,ex);
  139. if chcode=0 then
  140.     begin
  141.     inchar:=false;
  142.     ch:=chr(ex);
  143.     end
  144. else
  145.     begin
  146.     ch:=chr(chcode);
  147.     inchar:=true;
  148.     if ex<>0 then
  149.       if chcode in [8,13,9,27] then
  150.      begin
  151.      ex:=chcode;
  152.      inchar:=false;
  153.      end;
  154.     end;
  155. end;{inchar}
  156.  
  157.  
  158. procedure ReadAt(x,y,nchars:integer;var TheString:maxstring);
  159. {Not Used here, but may be useful to other programs,
  160.  performs read from video buffer}
  161. Var
  162.   i,j:integer;
  163.   Attribute:Byte;
  164.  
  165. Begin{1}
  166. TheString:='';
  167.    j := 2*((y-1)*80+(x-1));{offset in video buffer}
  168.    i:=1;
  169.    While (i<=nchars) do
  170.        begin{3}
  171.        TheString:=TheString+chr(ord(Mem[VideoSeg:j]));
  172.        i:=i+1;
  173.        j:=j+2;
  174.        end;{3}
  175. end;{1 of ReadAt}
  176.  
  177.  
  178. procedure WriteAt(x,y:integer;WriteMode:VideoMode;TheString:maxstring);
  179. {Memory Mapped write}
  180. Var
  181.   i,j,k:integer;
  182.   Attribute:Byte;
  183.  
  184. Begin{1}
  185.   case WriteMode of {change these for color terminals}
  186.    Norm:       Attribute := $07;
  187.    Rev:        Attribute := $70;
  188.    Hi:           Attribute := $0F;
  189.    Und:        Attribute := $01;
  190.    RevHi:      Attribute := $78;
  191.    Blink:      Attribute := $87;
  192.    BlinkHi:    Attribute := $8F;
  193.    RevBlink:   Attribute := $F0;
  194.    RevBlinkHi: Attribute := $F8;
  195.    ELSE        Attribute := $07;{Normal}
  196.    end;
  197.  
  198.  
  199.    j := 2*((y-1)*80+(x-1));{offset in video buffer}
  200.    i:=1;
  201.    k:=length(thestring);
  202.    While i<=k do
  203.        begin
  204.        Mem[VideoSeg : j] := Byte(TheString[i]);
  205.        Mem[VideoSeg : (j+1)] := Attribute;
  206.        i:=i+1;
  207.        j:=j+2;
  208.        end;
  209. end;{1 of WriteAt}
  210.  
  211.  
  212.  
  213. Procedure LoadMenus(var MenuList:MenuAry);
  214. {loads the menu data file}
  215. var i,j,k:integer;
  216.     f:text;
  217.     s:maxstring;
  218.  
  219. Procedure GetAMenu(var M:MenuPtr);
  220. label 99;
  221. var i,j,k:integer;
  222. begin
  223. i:=-1;
  224. j:=0;
  225. { s has been primed }
  226. M^.MenuName:=s;
  227. readln(f,s);
  228. s:=s+'            ';
  229. while (s[1]<>'*') and (not eof(f)) do
  230.    begin
  231.  
  232.    if s[1]<>' ' then
  233.      begin
  234.      if i>=0 then M^.NumEntry[i]:=j;
  235.      i:=i+1;
  236.      M^.Menu[i,0]:=s;
  237.      j:=0;
  238.      end
  239.  
  240.    else
  241.      if s[1]<>'*' then
  242.        begin
  243.        j:=j+1;
  244.        delete(s,1,1);
  245.        M^.Menu[i,j]:=s;
  246.        end
  247.      else goto 99;
  248.  
  249.  
  250.   readln(f,s);
  251.   s:=s+'            ';
  252.  
  253.   end;
  254.  
  255. 99:
  256. M^.NumEntry[i]:=j;
  257. M^.NoItems:=i;
  258.  
  259. end;{GetAMenu}
  260.  
  261. begin{Load}
  262.  
  263. assign(f,'men2.dat'); {alter name for application}
  264. reset(f);
  265.  
  266. i:=0;
  267. readln(f,s);
  268.  
  269. while not eof(f) do
  270.    begin
  271.    i:=i+1;
  272.    New(Menus[i]);
  273.    GetAMenu(Menus[i]);
  274.    end;
  275. NumMenus:=i;
  276.  
  277. close(f);
  278.  
  279. {some other initialization here}
  280.  
  281. botbox:='╚';
  282. for i:=1 to Width do botbox:=botbox+'═';
  283. botbox:=botbox+'╝';
  284.  
  285. end;{LoadMenu}
  286.  
  287.  
  288.  
  289.  
  290. procedure DoMenu(var itemsel,entrysel:integer;M:MenuPtr);
  291.  
  292. {this runs a menu, reads keys etc,}
  293. {itemsel and entrysel are returned}
  294.  
  295.  
  296. type
  297.    setofkeys=set of 0..132;
  298.  
  299. var
  300.    chc,ex:integer;
  301.    ch:char;
  302.    validkeys:setofkeys;
  303.    asc,selection:boolean;
  304.    item,entry:integer;
  305.    s1,s2:maxstring;
  306.  
  307.  
  308. Procedure PaintMenuBar;
  309. var
  310. i,sx:integer;
  311. begin
  312.  
  313. clrscr;
  314.  
  315. writeat(1,1,rev,
  316. '                                                                                ');
  317. for i:=0 to M^.NoItems do
  318.    begin
  319.    sx:=2+i*Width;
  320.    writeat(sx,1,rev,M^.Menu[i,0]);
  321.    end;
  322. end;{PaintMenuBar}
  323.  
  324.  
  325. Procedure Bright(ix,ij:integer);
  326. var sx:integer;
  327.     s:maxstring;
  328. begin
  329. s:=M^.Menu[ix,ij];
  330. sx:=ix*Width+1;
  331. writeat(sx+1,ij+1,Rev,s)
  332. end;
  333.  
  334.  
  335.  
  336. Procedure UnderScore(ix,ij:integer);
  337. var sx:integer;
  338.     s:maxstring;
  339. begin
  340. sx:=ix*Width+1;
  341. s:=M^.Menu[ix,ij];
  342. writeat(sx+1,ij+1,Und,s)
  343. end;
  344.  
  345.  
  346. Procedure Normal(ix,ij:integer);
  347. var sx:integer;
  348.     s:maxstring;
  349. begin
  350. sx:=ix*Width+1;
  351. if ij=0 then if sx<1 then sx:=1;
  352. s:=M^.Menu[ix,ij];
  353. writeat(sx+1,ij+1,Norm,s);
  354. end;
  355.  
  356.  
  357.  
  358. Procedure PushUp(ix:integer);
  359. var sx,i:integer;
  360. begin
  361. sx:=ix*Width+1;
  362. if sx<1 then sx:=1;
  363. for i:=1 to M^.NumEntry[ix]+1 do
  364.    writeat(sx,i+1,Norm,'             ');
  365. end;
  366.  
  367. Procedure PullDown(ix:integer);
  368. const
  369.  
  370.     l:maxstring='║';
  371.     r:maxstring='║';
  372. var sx:integer;
  373.     s:maxstring;
  374.     j:integer;
  375. begin
  376. sx:=ix*Width+1;
  377. for j:=1 to M^.NumEntry[ix] do
  378.     begin
  379.     s:=l+M^.Menu[ix,j]+r;
  380.     writeat(sx,j+1,Norm,s);
  381.     end;
  382. if M^.NumEntry[ix]>0 then writeat(sx,M^.NumEntry[ix]+2,Norm,botbox);
  383. end;
  384.  
  385.  
  386. begin {DoMenu}
  387.  
  388. CursorOff;
  389.  
  390. validkeys:=[13,15,75,9,77,80,72,27];
  391.  
  392. entry:=1;
  393. item:=0;
  394. PaintMenuBar;
  395. PullDown(0);
  396. Bright(item,entry);
  397.  
  398. selection:=FALSE;
  399.  
  400. while not selection do
  401.    begin
  402.  
  403.    asc:= Inchar(ch,ex);
  404.  
  405.    if ex=0 then {Ctl-Brk hit}
  406.       begin
  407.       CursorNormal;
  408.       clrscr;
  409.       halt;
  410.       end;
  411.  
  412.    if not asc then
  413.    case ex{tended code} of
  414.  
  415.       13:{CR}
  416.          selection:=TRUE;
  417.  
  418.  
  419.       15, 75:{lefttab,left}
  420.          if item>0 then
  421.            begin
  422.            item:=item-1;
  423.            entry:=1;
  424.            pushup(item+1);
  425.            pulldown(item);
  426.            Bright(item,entry);
  427.            end;
  428.  
  429.        9, 77:{tab,right}
  430.          if item<M^.NoItems then
  431.            begin
  432.            item:=item+1;
  433.            entry:=1;
  434.            pushup(item-1);
  435.            pulldown(item);
  436.            entry:=1;
  437.            Bright(item,1);
  438.            end;
  439.  
  440.       80:{down}
  441.          begin
  442.          if entry<M^.NumEntry[item] then
  443.         begin
  444.         entry:=entry+1;
  445.         Normal(item,entry-1);
  446.         Bright(item,entry);
  447.         end
  448.          else
  449.            begin
  450.            entry:=1;
  451.            Normal(item,M^.NumEntry[item]);
  452.            Bright(item,entry);
  453.            end;
  454.          end;
  455.  
  456.       72:{up}
  457.          begin
  458.          if entry>1 then
  459.         begin
  460.         entry:=entry-1;
  461.         Normal(item,entry+1);
  462.         Bright(item,entry);
  463.         end
  464.          else
  465.            begin
  466.            entry:=M^.NumEntry[item];
  467.            Normal(item,1);
  468.            Bright(item,entry);
  469.            end;
  470.          end;
  471.       27:{Esc}
  472.            begin
  473.            selection:=TRUE;
  474.            item:=0;
  475.            entry:=0;
  476.            end;
  477.  
  478.       end;{case}
  479.  
  480.    end;{while not selection}
  481. itemsel:=item;
  482. entrysel:=entry;
  483.  
  484. CursorNormal;
  485.  
  486. end;{DoMenu}
  487.  
  488.  
  489.  
  490. Procedure RunMenus;
  491.  
  492. {  Skeleton Procedure that you flesh out to run your menu tree.
  493.  
  494.    DoMenu returns item=menu bar item  and entry=entry underneath the
  495.    item  as the selection. Zeros are returned for the escape key.
  496.  
  497.    Compose the CASE index by 100* Active + 10*Item + Entry .
  498.  
  499.     So Menu 2 Item 3 Entry 4 has an index of 234.
  500.  
  501.   Fill in the Case statement to accomodate the returned indices.
  502.  
  503. }
  504.  
  505. var
  506. exit:boolean;
  507. ch:char;
  508. Active,index,item,entry:integer;
  509.  
  510. begin {RunMenu}
  511.  
  512. exit:=FALSE;
  513. Active:=1;
  514.  
  515. while not exit do
  516.   begin
  517.  
  518.   DoMenu(item,entry,Menus[Active]);
  519.  
  520.   index:=Active*100+item*10+entry;
  521.  
  522.   case index of {fill this in appropriately with structure}
  523.  
  524.   100:exit:=TRUE;
  525.  
  526.   101..104,201..204,301..304: begin
  527.         gotoxy(10,10);
  528.         writeln(' This is for Information Only');
  529.         delay(5000);
  530.         end;
  531.  
  532.   111 : begin
  533.     Active:=2; {select next Menu}
  534.     end;
  535.  
  536.   112 : begin
  537.     Active:=3; {select next Menu}
  538.     end;
  539.  
  540.   121,122,211,212 : begin
  541.         gotoxy(10,10);
  542.         writeln(' These Entries Have No Function.');
  543.         delay(5000);
  544.         end;
  545.  
  546.  
  547.   131,222: begin
  548.        gotoxy(10,10);
  549.        write(' Do You Really Want to Quit? ');
  550.        readln(ch);
  551.        if ch in ['Y','y'] then exit:=TRUE;
  552.        end;
  553.  
  554.  
  555.   221,321,200,300:Active:=1;
  556.  
  557.  
  558.   311:begin
  559.        gotoxy(10,10);
  560.        write(' Caesar slowly sipped his snifter,');
  561.        writeln(' seized his knees and sneezed.');
  562.        delay(5000);
  563.        end;
  564.  
  565.    312:begin
  566.        gotoxy(10,10);
  567.        writeln(' Peter Piper picked a peck of pickled peppers.');
  568.        delay(5000);
  569.        end;
  570.    end;{case}
  571.  
  572.   end;
  573. end;{RunMenus}
  574.  
  575. begin{main}
  576.  
  577. CursorNormal;
  578.  
  579. SetVideoSeg;
  580. LoadMenus(Menus);
  581. RunMenus;
  582. clrscr;
  583. end.
  584.